home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
p063b9s.zip
/
UNIT
/
PINGANSI.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-20
|
17KB
|
520 lines
{$Define TurboPower}{ use Turbo Power Professional }
{$Define Music} { implement 'ansi'-music }
{$Define BBS} { enable support for bbs/communication usage }
{$Define Small} { enable i/o driver }
(*
PingAnsi v 1.33 (c) CopyRight 1990 P.H.Rankin Hansen.
This unit provides partial Ansi emulation for Turbo Pascal versions
5.x and higher. (version 4 does not implement procedural types).
Some routines may be handled in a non-standard way.
Released in Denmark on August 23rd 1990.
By using this material You assume FULL responsibility for ANY
consequences-direct or indirect-thereof.
Any dispute regarding this material shall be setteled by Danish law
and in a Danish Court.
(Sigh!)
This source may NOT be used by Lawyers, Politicians or persons
engaged in any other form of terrorism. Otherwise the usage is
free.
This source may be freely distributed as long as no fee is charged.
Please direct any comments, corrections, modifications via netmail
to:
Ping Hansen-FidoNet 2:231/62.58
*)
Unit PingAnsi;
{-}
Interface
Uses
Use32,
{$IFDEF TurboPower}
{ Turbo Power units. The standard CRT unit will not work in a TSR }
OpCrt, OpString;
{$ELSE}
{ Replacements for Turbo Power units for those unfortunates who doesn't }
{ have them. It is recommended to buy the Turbo Power toolboxes partly }
{ because the standard crt unit doesn't stand up too well in a TSR/ }
{ Multitasking environment and partly because they, IMHO, generally make }
{ life easier for pascal programmers. }
Crt, PoorMan;
{$ENDIF}
Var
Wrap : Boolean; { True if Cursor should wrap }
ReportedX,
ReportedY : Word; { X,Y reported }
{ hook for implementing Your own Device Status Report procedure }
ReplyHook : Procedure(St : String);
{ hook for implementing Your own KeyBoard ReAssignment }
KeyHook : Procedure(St : String);
{ Hook for handling control chars i.e. Ch<Space }
WriteHook : Procedure(Ch : Char);
{$IFNDEF Small}
{$IFDEF BBS}
{ Hook for handling simultaneous writes to ComPort and Screen }
BBsHook : Procedure (Ch : Char);
{$ENDIF}
{$ENDIF}
{$IFDEF Music}
{ Hook for handling music }
PlayHook : Procedure(St : String);
{$ENDIF}
Procedure ClearAnsiState;
Function In_Ansi : Boolean; { True if a sequence is pending }
Procedure AnsiWrite(Ch : Char);
{$IFNDEF Small}
Procedure AssignAnsi(Var f : Text); { use like AssignCrt }
{$ENDIF}
Implementation
Type
States =(Waiting, Bracket, Get_Args, Get_Param, Eat_Semi,
Get_String, In_Param, Get_Music);
Const
St : String='';
ParamArr : Array[1..10] Of Word=(0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
Params : Word=0; { number of parameters }
NextState : States=Waiting; { next state for the parser }
Reverse : Boolean=False; { true if text attributes are reversed }
Var
Quote : Char;
SavedX, SavedY : Word;
Procedure ClearAnsiState;
BEGIN
NextState:=Waiting;
END;
Function In_Ansi : Boolean; { True if a sequence is pending }
Begin
In_Ansi:=(NextState<>Waiting) And (NextState<>Bracket);
End {In_Ansi} ;
Procedure Report(St : String); far;
Begin
StuffString(St);
End;
Procedure WriteChar(Ch : Char); far;
Begin
Case Ch Of
#7 : Begin
{$IFDEF OS2}
PlaySound(500,50);
{$ELSE}
NoSound;
Sound(500);
Delay(50);
NoSound;
Delay(50);
{$ENDIF}
End;
#8 : If (WhereX>1) Then Write(#8' '#8);
#9 : If (WhereX<71) Then
Repeat
GotoXy(WhereX+1, Wherey);
Until (WhereX Mod 8=1);
Else
Write(Ch);
End {Case} ;
End {WriteChar} ;
Procedure Dummy(St : String); far;
Begin
End;
Procedure AnsiWrite(Ch : Char);
Var
i : Word;
Label Command;
Begin
If Ch=#27 Then
Begin
NextState:=Bracket;
Exit;
End;
Case NextState Of
Waiting : If (Ch>' ') Then Write(Ch) Else WriteHook(Ch);
Bracket :
Begin
If Ch<>'[' Then
Begin
NextState:=Waiting;
If (Ch>' ') Then Write(Ch) Else WriteHook(Ch);
Exit;
End;
St:='';
Params:=1;
FillChar(ParamArr, 10, 0);
NextState:=Get_Args;
End;
Get_Args,
Get_Param,
Eat_Semi : Begin
{$IFNDEF Music}
If (NextState=Get_Args) And ((Ch='=') Or (Ch='?')) Then
Begin
NextState:=Get_Param;
Exit;
End;
{$ELSE}
If (NextState=Get_Args) Then
Case Ch Of
'=', '?' : Begin
NextState:=Get_Param;
Exit;
End;
'M' : Begin
NextState:=Get_Music;
Exit;
End;
End {Case} ;
{$ENDIF}
If (NextState=Eat_Semi) And (Ch=';') Then
Begin
If Params<10 Then Inc(Params);
NextState:=Get_Param;
Exit;
End;
Case Ch Of
'0'..'9' : Begin
ParamArr[Params]:=Ord(Ch)-Ord('0');
NextState:=In_Param;
End;
';' : Begin
If Params<10 Then Inc(Params);
NextState:=Get_Param;
End;
'"', '''' : Begin
Quote:=Ch;
St:=St+Ch;
NextState:=Get_String;
End;
Else
GoTo Command;
End {Case Ch} ;
End;
Get_String :
Begin
St:=St+Ch;
If Ch<>Quote Then NextState:=Get_String Else NextState:=Eat_Semi;
End;
In_Param : { last char was a digit }
Begin
{ looking for more digits, a semicolon, or a command char }
Case Ch Of
'0'..'9' : Begin
ParamArr[Params]:=ParamArr[Params] * 10+Ord(Ch)-Ord('0');
NextState:=In_Param;
Exit;
End;
';' :
Begin
If Params<10 Then Inc(Params);
NextState:=Eat_Semi;
Exit;
End;
End {Case Ch} ;
Command:
NextState:=Waiting;
Case Ch Of
{ Note: the order of commands is optimized for execution speed }
'm' : {sgr}
Begin
For i:=1 To Params Do
Begin
If Reverse Then TextAttr:=TextAttr Shr 4+TextAttr Shl 4;
Case ParamArr[i] Of
0 :
Begin
Reverse:=False;
TextAttr:=7;
End;
1 : TextAttr:=TextAttr Or $08;
2,22 : TextAttr:=TextAttr And $F7;
4,34 : TextAttr:=TextAttr And $F8 Or $01;
5 : TextAttr:=TextAttr Or $80;
7 : If Not Reverse Then
Begin
{
TextAttr:=TextAttr shr 4+TextAttr shl 4;
}
Reverse:=True;
End;
24 : TextAttr:=TextAttr And $F8 Or $04;
25 : TextAttr:=TextAttr And $7F;
27 : If Reverse Then
Begin
Reverse:=False;
{
TextAttr:=TextAttr shr 4+TextAttr shl 4;
}
End;
30 : TextAttr:=TextAttr And $F8;
31 : TextAttr:=TextAttr And $F8 Or $04;
32 : TextAttr:=TextAttr And $F8 Or $02;
33 : TextAttr:=TextAttr And $F8 Or $06;
35 : TextAttr:=TextAttr And $F8 Or $05;
36 : TextAttr:=TextAttr And $F8 Or $03;
37 : TextAttr:=TextAttr And $F8 Or $07;
40 : TextAttr:=TextAttr And $8F;
41 : TextAttr:=TextAttr And $8F Or $40;
42 : TextAttr:=TextAttr And $8F Or $20;
43 : TextAttr:=TextAttr And $8F Or $60;
44 : TextAttr:=TextAttr And $8F Or $10;
45 : TextAttr:=TextAttr And $8F Or $50;
46 : TextAttr:=TextAttr And $8F Or $30;
47 : TextAttr:=TextAttr And $8F Or $70;
End {Case} ;
{ fixup for reverse }
If Reverse Then TextAttr:=TextAttr Shr 4+TextAttr Shl 4;
End;
End;
'A' : {cuu}
Begin
If ParamArr[1]=0 Then ParamArr[1]:=1;
If (Wherey-ParamArr[1]>=1) Then GotoXy(WhereX,Wherey-ParamArr[1])
Else GotoXy(WhereX, 1);
End;
'B' : {cud}
Begin
If ParamArr[1]=0 Then ParamArr[1]:=1;
If (Wherey+ParamArr[1]<=Hi(WindMax)-Hi(WindMin)+1) Then GotoXy(WhereX, Wherey+ParamArr[1])
Else GotoXy(WhereX, Hi(WindMax)-Hi(WindMin)+1);
End;
'C' : {cuf}
Begin
If ParamArr[1]=0 Then ParamArr[1]:=1;
If (WhereX+ParamArr[1]<=Lo(WindMax)-Lo(WindMin)+1) Then GotoXy(WhereX+ParamArr[1], Wherey)
Else GotoXy(Lo(WindMax)-Lo(WindMin)+1, Wherey);
End;
'D' : {cub}
Begin
If (ParamArr[1]=0) Then ParamArr[1]:=1;
If (WhereX-ParamArr[1]>=1) Then GotoXy(WhereX-ParamArr[1], Wherey)
Else GotoXy(1, Wherey);
End;
'H', 'f' : {cup,hvp}
Begin
If (ParamArr[1]=0) Then ParamArr[1]:=1;
If (ParamArr[2]=0) Then ParamArr[2]:=1;
If (ParamArr[2]>Lo(WindMax)+1) then ParamArr[2]:=Lo(WindMax)-Lo(WindMin)+1;
If (ParamArr[1]>Hi(WindMax)+1)
then ParamArr[1]:=Hi(WindMax)-Hi(WindMin)+1;
GotoXy(ParamArr[2], ParamArr[1]) ;
End;
'J' : {EID}
Case ParamArr[1] Of
2 : ClrScr;
0 : {ClrEos}
Begin
ClrEol;
ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey+1,
Lo(WindMax)+1, Hi(WindMax)+1, 0);
End;
1 : {Clear from beginning of screen}
Begin
ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey,
Lo(WindMin)+WhereX,Hi(WindMin)+Wherey, 0);
ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+1,
Lo(WindMax)+1, Hi(WindMin)+Wherey-1, 0);
End;
End {Case} ;
'K' : {eil}
Case ParamArr[1] Of
0 : ClrEol;
1 : { clear from beginning of line to cursor }
ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey,
Lo(WindMin)+WhereX-1,
Hi(WindMin)+Wherey, 0);
2 : { clear entire line }
ScrollWindowDown(Lo(WindMin)+1, Hi(WindMin)+Wherey,
Lo(WindMax)+1,
Hi(WindMin)+Wherey, 0);
End {Case ParamArr} ;
'L' : {il } For i:=1 To ParamArr[1] Do InsLine; { must not move cursor }
'M' : {d_l} For i:=1 To ParamArr[1] Do DelLine; { must not move cursor }
'P' : {dc }
Begin
End;
'R' : {cpr}
Begin
ReportedY:=ParamArr[1];
ReportedX:=ParamArr[2];
End;
'@' : {ic}
Begin
{ insert blank chars }
End;
'h', 'l' : {sm/rm}
Case ParamArr[1] Of
0 : {TextMode(BW40)};
1 : {TextMode(CO40)};
2 : {TextMode(BW80)};
3 : {TextMode(CO80)};
4 : {GraphMode(320x200 col)} ;
5 : {GraphMode(320x200 BW)} ;
6 : {GraphMode(640x200 BW)} ;
7 : Wrap:=Ch='h';
End {case} ;
'n' : {dsr}
If (ParamArr[1]=6) Then
ReplyHook(#27'['+Long2str(Wherey)+';' +
Long2str(WhereX)+'R');
's' : {scp}
Begin
SavedX:=WhereX;
SavedY:=Wherey;
End;
'u' : {rcp} GotoXy(SavedX, SavedY);
'p' : {keyboard reassignment}
KeyHook(St);
Else
Begin
If (Ch>' ') Then Write(Ch)
Else WriteHook(Ch);
Exit;
End;
End {Case Ch} ;
End;
{$IFDEF Music}
Get_Music :
Begin
If Ch<>#3 Then St:=St+Ch Else
Begin
NextState:=Waiting;
PlayHook(St);
End;
End;
{$ENDIF}
End {Case NextState} ;
End {AnsiWrite} ;
{$IFNDEF Small}
Function Nothing(Var f : TextRec) : Integer; far;
Begin
Nothing:=0;
End {Nothing} ;
Procedure Null(Ch : Char); far;
Begin
{}
End {Null} ;
Function DevOutput(Var f : TextRec) : Integer; far;
Var
i : Integer;
Begin
With f Do
Begin
{ f.BufPos contains the number of chars in the buffer }
{ f.BufPtr^ is your buffer }
{ Any variable conversion done by writeln is already }
{ done by now. }
i:=0;
While i<BufPos Do
Begin
AnsiWrite(BufPtr^[i]);
{$IFDEF BBS}
BBSHook(BufPtr^[i]);
{$ENDIF}
Inc(i);
End;
BufPos:=0;
End;
DevOutput:=0; { return IOResult Error codes here }
End {DevOutput} ;
Function DevOpen(Var f : TextRec) : Integer; far;
Begin
With f Do
Begin
If Mode=FmInput Then
Begin
InOutFunc:=@Nothing;
FlushFunc:=@Nothing;
End
Else
Begin
Mode:=FmOutput; { in case it was FmInOut }
InOutFunc:=@DevOutput;
FlushFunc:=@DevOutput;
End;
CloseFunc:=@Nothing;
End;
DevOpen:=0; { return IOResult error codes here }
End {DevOpen} ;
Procedure AssignAnsi(Var f : Text);
Begin
FillChar(f, SizeOf(f), #0); { init file var }
With TextRec(f) Do
Begin
Handle:=$ffff;
Mode:=FmClosed;
BufSize:=SizeOf(Buffer);
BufPtr:=@Buffer;
OpenFunc:=@DevOpen;
Name[0]:=#0;
End;
End {AssignAnsi} ;
{$ENDIF}
Begin
{$IFNDEF Small}
AssignAnsi(Ansi); { set up the variable }
Rewrite(Ansi); { open it for output }
{$IFDEF BBS}
BBsHook:=Null;
{$ENDIF}
{$ENDIF}
Wrap:=True;
ReplyHook:=Report;
KeyHook:=Dummy;
WriteHook:=WriteChar;
{$IFDEF Music}
PlayHook:=Dummy; { point play into the great music heaven }
{$ENDIF}
End.